home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Belgian Amiga Club - ADF Collection
/
BS1 part 34.zip
/
BS1 part 34
/
FredFish PD 308.adf
/
StarBlanker
/
src
/
Blanker.mod
next >
Wrap
Text File
|
1990-01-18
|
9KB
|
327 lines
MODULE Blanker;
(*======================================================================*)
(* StarBlanker v1.0 *)
(*======================================================================*)
(* Copyright (c) 1989, 1990 Chris Bailey, All Rights Reserved *)
(*======================================================================*)
(* Version: 1.00 Author : Chris Bailey *)
(* Date : 04-Jan-90 *)
(*======================================================================*)
(* Distribution of this code is limited to the terms expressed in the *)
(* documentation of this program. *)
(*======================================================================*)
(* Contents : Input handler, startup code for StarBlanker *)
(*======================================================================*)
FROM SYSTEM IMPORT ADR, ADDRESS, TSIZE, SETREG, SAVEREGS, LOADREGS,
REGISTER, BYTE, STRPTR, CODE, LONGWORD;
FROM CmdLineUtils IMPORT argc, argv;
FROM Mess IMPORT SayMessage;
(* You could replace this with a blanker function of your own design *)
FROM StarBlanker IMPORT DoStarBlank;
FROM Interrupts IMPORT Interrupt, Forbid, Permit;
FROM Devices IMPORT OpenDevice, CloseDevice;
FROM InputEvents IMPORT InputEventPtr, IEClass, IEQualifiers, IEQualifierSet,
InputEvent;
FROM IO IMPORT IOStdReq, DoIO;
FROM InputDevice IMPORT INDAddHandler, INDRemHandler;
FROM PortUtils IMPORT CreatePort, DeletePort;
FROM ConsoleDevice IMPORT RawKeyConvert, ConsoleName, ConsoleBase;
FROM Ports IMPORT MsgPortPtr, FindPort;
FROM Tasks IMPORT Wait, Signal, SignalSet, AllocSignal, FreeSignal,
TaskPtr, FindTask;
FROM RunTime IMPORT CurrentProcess, WBMsg;
FROM Intuition IMPORT ScreenPtr, CurrentTime;
FROM TimerDevice IMPORT TimeVal;
FROM DOS IMPORT SIGBreakC, FileLock, CurrentDir;
FROM Workbench IMPORT WBStartupPtr, WBArgPtr, WBArg, DiskObjectPtr;
FROM Icon IMPORT GetDiskObject, FreeDiskObject, IconName, IconBase,
FindToolType;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
CONST
TASKNAME = "* Blanker"; (* The name of our task, also in RTD.mod *)
PORTNAME = "* Blank_Port"; (* The name of our port *)
DEFAULTTIMEOUT = 4*60;
MINTIMEOUT = 10;
(* Timeout in Seconds *)
TYPE IEClassSet = SET OF IEClass; (* Because there isn't one in the .DEF *)
VAR
ioreq : IOStdReq;
maintask : TaskPtr;
port : MsgPortPtr;
sigbit,sigbit2 : CARDINAL;
int : Interrupt;
VAR
iostdreq : IOStdReq;
ourtime : TimeVal;
timeout : LONGCARD;
(*$X,$S-*)
PROCEDURE LengthStr(str:ARRAY OF CHAR): CARDINAL;
BEGIN
CODE(0265FH,0205FH,0321FH,070FFH,05280H,04A18H,06704H,0B041H,06FF6H,
04ED3H);
END LengthStr;
(*$S-*)
PROCEDURE StrToNum(str:ARRAY OF CHAR; VAR num:LONGWORD): BOOLEAN;
VAR
negate : BOOLEAN;
lbase,newnum : LONGCARD;
length,i : CARDINAL;
digit : INTEGER;
BEGIN
length:=LengthStr(str);
i:=0;
newnum:=0;
negate:=FALSE;
lbase:=10;
(* Skip leading blanks *)
WHILE str[i]=" " DO
INC(i);
END;
IF i>length THEN
RETURN FALSE;
END;
WHILE (i<length) DO
digit:=ORD(CAP(str[i]));
IF digit>=INTEGER(ORD("A")) THEN
DEC(digit,7);
END;
DEC(digit,48);
IF (digit<0) OR (digit>=INTEGER(lbase)) THEN
RETURN FALSE;
END;
(* Make sure we don't get an overflow *)
IF (negate) & ((MAX(LONGINT)-LONGINT(digit)) DIV LONGINT(lbase) < LONGINT(newnum)) THEN
RETURN FALSE;
END;
IF (MAX(LONGCARD)-LONGCARD(digit)) DIV lbase < newnum THEN
RETURN FALSE;
END;
newnum:=newnum*lbase+LONGCARD(digit);
INC(i);
END;
(* Flip the sign if needed *)
num:=newnum;
IF negate THEN
num:=-LONGINT(newnum);
END;
RETURN TRUE;
END StrToNum;
PROCEDURE SetTimeOut(str : STRPTR);
BEGIN
IF str # NIL THEN
IF ~StrToNum(str^,timeout) THEN
timeout := DEFAULTTIMEOUT;
ELSE
IF (timeout < MINTIMEOUT) THEN
timeout := DEFAULTTIMEOUT;
END;
END;
ELSE
timeout := DEFAULTTIMEOUT;
END;
END SetTimeOut;
PROCEDURE GetToolTypes(wbArg:WBArgPtr);
VAR
diskObj : DiskObjectPtr;
str : STRPTR;
BEGIN
IconBase:=OpenLibrary(ADR(IconName),0);
IF IconBase=NIL THEN
timeout := DEFAULTTIMEOUT;
RETURN;
END;
(* Load the icon associated with the argument *)
diskObj:=GetDiskObject(wbArg^.waName);
IF diskObj=NIL THEN
timeout := DEFAULTTIMEOUT;
RETURN;
END;
str := FindToolType(diskObj^.doToolTypes,ADR("TIMEOUT"));
SetTimeOut(str);
(* Free the icon we loaded *)
FreeDiskObject(diskObj);
CloseLibrary(IconBase);
END GetToolTypes;
PROCEDURE HandleWBStartup();
VAR wbmsg : WBStartupPtr;
wbargcnt : CARDINAL;
wbarg : WBArgPtr;
lock : FileLock;
BEGIN
wbmsg:=WBMsg;
wbargcnt:=wbmsg^.smNumArgs;
wbarg:=wbmsg^.smArgList;
lock:=CurrentDir(wbarg^.waLock);
GetToolTypes(wbarg);
(* Reset current directory to what it was *)
lock:=CurrentDir(lock);
END HandleWBStartup;
PROCEDURE Startup();
BEGIN
CASE argc OF
| 0 : HandleWBStartup();
| 2 : SetTimeOut(argv[1]);
ELSE
timeout := DEFAULTTIMEOUT;
END;
END Startup;
PROCEDURE InputHandler() : LONGCARD;
VAR
event : InputEventPtr;
copy : InputEvent;
buffer : ARRAY [0..5] OF CHAR;
BEGIN
SAVEREGS({2..7,10,11,14});
event:=ADDRESS(REGISTER(8));
copy := event^;
(* See if timeout expired *)
IF (copy.ieClass=IEClassTimer) THEN
(* Who needs steenking microseconds? *)
IF ((copy.ieTimeStamp.tvSecs - ourtime.tvSecs) > timeout) THEN
Signal(maintask,SignalSet{sigbit});
ourtime := copy.ieTimeStamp;
END;
(* Check for exit key *)
ELSIF (copy.ieClass=IEClassRawKey) AND (IEQualifierRShift IN copy.ieQualifier) AND
(IEQualifierRAlt IN copy.ieQualifier) THEN
copy.ieQualifier := copy.ieQualifier - IEQualifierSet{IEQualifierRShift,IEQualifierRAlt};
IF RawKeyConvert(ADR(copy),ADR(buffer),5,NIL)>0 THEN
IF buffer[0]="x" THEN
Signal(maintask,SignalSet{sigbit2});
event:=NIL;
END;
END;
ourtime := copy.ieTimeStamp;
(* Otherwise, set start of timeout again *)
ELSIF (copy.ieClass IN IEClassSet{IEClassRawKey,IEClassRawMouse,IEClassPointerPos}) THEN
(* Apparently Snipit doesn't timestamp it's faked events, it
* sets them to 0. Therefore, we gotta put a check in here for 0.
* Yeesh.
*)
IF copy.ieTimeStamp.tvSecs # 0 THEN
ourtime := copy.ieTimeStamp;
END;
END;
LOADREGS({2..7,10,11,14});
RETURN LONGCARD(event);
END InputHandler;
PROCEDURE AddInputHandler();
VAR
x : INTEGER;
BEGIN
CurrentTime(ourtime.tvSecs,ourtime.tvMicro);
port:=CreatePort(ADR(PORTNAME),0);
IF port # NIL THEN
ioreq.ioMessage.mnReplyPort:=port;
WITH int DO
isNode.lnPri:=BYTE(75);
isCode:=InputHandler;
isNode.lnName := ADR("* Blank_Handler");
END;
IF OpenDevice(ADR("input.device"),0,ADR(ioreq),LONGBITSET{})=0 THEN
ioreq.ioCommand:=INDAddHandler;
ioreq.ioData:=ADR(int);
x:=DoIO(ADR(ioreq));
END;
END;
END AddInputHandler;
PROCEDURE RemInputHandler;
VAR
x : INTEGER;
BEGIN
ioreq.ioCommand:=INDRemHandler;
ioreq.ioData:=ADR(int);
x:=DoIO(ADR(ioreq));
CloseDevice(ADR(ioreq));
DeletePort(port);
END RemInputHandler;
PROCEDURE ControlLoop;
VAR
wakeup : SignalSet;
error : CARDINAL;
BEGIN
sigbit:=AllocSignal(-1);
sigbit2:=AllocSignal(-1);
AddInputHandler();
LOOP
wakeup:=Wait(SignalSet{SIGBreakC,sigbit,sigbit2});
IF sigbit IN wakeup THEN
RemInputHandler();
DoStarBlank(); (* Or insert your own function here *)
AddInputHandler();
ELSE
EXIT;
END;
END;
RemInputHandler();
FreeSignal(sigbit2);
FreeSignal(sigbit);
END ControlLoop;
BEGIN
port := FindPort(ADR(PORTNAME));
IF (port = NIL) THEN
(* We aren't running yet *)
IF OpenDevice(ADR(ConsoleName),-1,ADR(iostdreq),LONGBITSET{})=0 THEN
Startup();
SayMessage("StarBlanker v1.00 installed");
ConsoleBase:=iostdreq.ioDevice;
maintask:=CurrentProcess;
ControlLoop;
CloseDevice(ADR(iostdreq));
SayMessage("StarBlanker removed");
END;
ELSE
(* We are already running *)
Signal(port^.mpSigTask,SignalSet{SIGBreakC});
END;
END Blanker.